Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/MCQUAY1/QSORT.PAS

Pascal/Delphi Source File | 1991-11-12 | 16KB | 423 lines

(****************************************************************************
 A GENERIC QUICK SORT UNIT
 version 5.0 and 5.1
 1/1/90
 ray quay

 Copyright 1990 McQuay Technologies
 Released into the Public Domain
 However, please give credit where credit is due !

 *****************************************************************************

  ------- SYNTAX -------------------------------------------------------------
  This is a generic quick sort routine that works similar to UNIX C's qsort
  function.

  procedure quick_sort( var sort_array ;         { untyped var reference }
                                            rec_size, n_recs: word;
                                            compare_function : compare_func);  { procedure-type
                                                             parameter     }
  Parameters
      sort_array - this is the structure that will be sorted, can be of
                   any data type (need not be an array).  This is technically
                   a reference to the "top" of the data to be sorted.  The
                   data however, must be located continuously in memory
                   from the top to the bottom of the data area.
      rec_size   - this is the size in bytes of each record to be sorted.
      n_recs     - this is the number of records referenced by sort_array.
                   Techinically, it is the number of records of rec_size from
                   the "top" of the data referenced to the bottom of the data
                   to be sorted.
      compare_function - this is a procedure-type parameter which is a
                   function called during the sort (see below).
                   Your compare function must be declared FAR with the
                   {$F+} compiler switch.
  ------- USAGE --------------------------------------------------------------
  This routine can sort an array of any type (or any structure) whose size is
  less than 64K bytes.  Size limitations can be overcome by creating either
  an index array, or an array of pointers, and sort the index or pointer
  array.  You have control over the conditions of the sort, via
  the compare_address function.  You must create a function which accepts
  two var parameters, and returns an integer.  The rules for the value returned
  by the function are the same as that for the UNIX C qsort function.  The
  following is an example of a function to sort an array of integers.

  {$F+}
  function compare (var v1,v2 : integer) :integer;
  begin
    if  v1 < v2 then compare := -1 else
      if v1 > v2 then compare := 1 else
        compare := 0;
  end;
    {$F-}  add this if you want it off

  The actual name of the function can be anything, it need only accept two
  var parameters and return an integer as above.  The address of your compare
  function is passed via the compare_function procedure-type parameter.

  There are five predefined compare functions available to you, these are :

    compare_word        Which is used to compare values of a word array
      compare_longint     Which is used to compare values of a longint array
      compare_int         Which is used to compare values of an integer array
      compare_real        Which is used to compare values of a real array
      compare_byte        Which is used to compare values of a byte array

  You can use these instead of building your own routine.  Here is an example:
    uses qsort;
    const
      ArraySize = 10;
    var
          sort_array : array[1..ArraySize] of word;
      i:word;
    begin
      for i:=1 to ArraySize do
                sort_array[i] := random(i);
            quick_sort(sort_array,sizeof(sort_array[1],ArraySize,compare_word);
            for i:=1 to ArraySize do
                writeln(i:4,sort_array[i]:3);
        end.

  ------- ERRORS -------------------------------------------------------------
  QSORT version 5.0 has no error checking.  QSORT 5.1 has minimal error
  checking.  You can compile Version 5.0 by deleting the line
    {$DEFINE DEBUGCODE }
  and compile version 5.1 by leaving this line in. In version 5.1  a check
  is made to make sure the reference to the array is not NIL, a check is
  made to make sure enough Heap is available for temporary storage.

  There is no type checking going on here so it is entirely up to you to make
  sure your function evaluates the type of variable that will be passed to it,
  that you pass to qsort the correct function. Turbo will not let you pass
  a function with the wrong structure, still it is up to you to be sure it
  is doing the correct comparison.  The only real damage that can occur is if
  you give it an incorrect record size.  (Fatal errors result if you pass
  a record size that is to large).

  Version 5.1 has several levels of error checking available.  First, the
  QSortResult function can be used to test if the sort was successful.  If
  QSortResult returns a 0, then there was no error detected, a nonzero value
  indicates an error, as follows:
                            Full       Full       Turbo
                             Hex      Decimal   Error Code
                            -----     -------   ----------
      MemoryOverFlowError = $10CB   -  4299   -    203
      BadFunctionPointer  = $112C   -  4396   -    300
      BadArrayVarPointer  = $10CC   -  4300   -    204


  Qsort version 5.1 also uses the FRTE runtime error unit to provide an
  advanced level of debugging error trapping.  Assigning TRUE to QSortDebug
  will cause Turbo's runtime error support system to trap all errors.
  This will display the error code and place the cursor at the call to Qsort()
  that caused the error.  Removing the line $DEFINE DEBUGCODE will compile
  to version 5.0, which has no error trapping.

  ------- STATS --------------------------------------------------------------
  Version 5.1 compiles to 2K of TPU code (not counting the FRTE unit)
  with all compiler switches off, and uses 4 bytes of the data segment.
  Version 5.0 compiles to 1.8K  of TPU code uses no space in the data segment.

  Speed wise, on an 8mhz system Qsort can sort an array of word with 1000
  elements in 1.5 seconds and on a 25mhz cache system sort about 5000 words
  in the same amount of time.  This is not ultra fast, but it is fairly fast
  for a general utility sort routine.

  ------- BACKGROUND ---------------------------------------------------------
  The quick sort algorithm is a divide and conquer startegy.  It recursively
  divides the array into smaller arrays, ordering the size to left the smaller
  and to the right the larger as it goes.  Yes, the following code is sparsely
  commented and it looks like greek.  If you want to understand the quick sort,
  and do not now understand it, I suggest you get a good advanced pascal book.
  Most will explain quick sort.  I am not going to attempt to do so here,
  suffice this works (I HOPE!).  This routine is adapted from

   Sgonina, Warner; TURBO PASCAL TRICKS AND TIPS; Abacus Software; 1985.
   and
   Duntemann; COMPLETE TURBO PASCAL; Scott, Foresman and Company; 1986.

   COMPLETE TURBO has a better explanation, TRICKS AND TIPS has a better
   routine.

   This routine uses pointers to reference all the data in
   the array or data structure to be sorted.  This is what makes it a
   generic routine.  It also uses the TPASCAL procedure getmem() to allocate
   enough temporary storage for the swap.  If you are using a different memory
   management scheme, replace this call with one of your own.

   Yes, there is most definitely a time factor sacrifice for using
   pointers, it increases the sort time by about a factor of 4.  Ahh,
   the price you pay.  This routine is also slighty larger than a routine
   specifically designed to sort a particualar data array, but will take up
   less code than would be required to write multiple sort routines, one for
   each type of data structure.

   Stack checking has been turned off for all but the recursive calls.  At
     the most, 20 bytes are needed for all other calls.  The stack is recovered
     prior to each recursive call, so it is not likely you will run into any
     stack problems with out the stack check catching it.  If you are having
     stack problems, recompile this unit with stack checking turned back on.

   Comments or bugs will be appreciated,    maybe.
*)

unit qsort;
{ Compiler Switches}
  {$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
  {$L swpdata4.obj }
  {$DEFINE DEBUGCODE }

interface
  type
    compare_func = function(var v1,v2 ) :integer;

  procedure quick_sort(  var sort_array ;   { untyped var reference }
                                        rec_size, n_recs: word;
                                        compare_function : compare_func);

  function F_compare_word    (var v1 ; var v2 ) : integer;
    { Used to compare values of a word array     }
  function F_compare_int     (var v1 ; var v2 ): integer;
    { Used to compare values of an integer array }
  function F_compare_longint (var v1 ; var v2 ) : integer;
    { Used to compare values of a longint array  }
  function F_compare_byte    (var v1 ; var v2  ) : integer;
    { Used to compare values of a byte array     }
  function F_compare_real    (var v1 ; var v2 ) : integer;
    { Used to compare values of a real array     }

  {$IFDEF DEBUGCODE }

  function QSortResult:word;
  const
    QSortDebug : boolean = false;
  {$ENDIF }

implementation
  {$IFDEF DEBUGCODE }
  uses frte;

  const
    MemoryOverFlowError = $10CB;
    BadFunctionPointer  = $112C;
    BadArrayVarPointer  = $10CC;
  {$ENDIF }

  { Compare Functions }
  {$F+}
  {------------------------------------------------}
  function F_compare_int;
  var
    va : integer absolute v1;
    vb : integer absolute v2;
  begin
    F_compare_int := va-vb;
  end;
  {------------------------------------------------}
  function F_compare_word ;
  var
    va : word absolute v1;
    vb : word absolute v2;
  begin
    F_compare_word := integer(v1)-integer(v2);
  end;
  {------------------------------------------------}
  function F_compare_longint;
  var
    va : longint absolute v1;
    vb : longint absolute v2;
  begin
    F_compare_longint := va-vb;
  end;
  {------------------------------------------------}
  function F_compare_byte;
  var
    va : byte absolute v1;
    vb : byte absolute v2;
  begin
    F_compare_byte := integer(va)-integer(vb);
  end;
  {------------------------------------------------}
  function F_compare_real;
  var
    temp : real;
    va : real absolute v1;
    vb : real absolute v2;
  begin
     temp := va - vb;
     if temp <0 then F_compare_real := -1
       else if temp >0 then F_compare_real := 1
         else F_compare_real := 0;
  end;
  {------------------------------------------------}

  {$F+}
  (*
  {--------------------------------------------------------------------------}
  function call_compare (v1seg,v1ofs:word; var v2; the_call : compare_func):integer;

  { This little routine is used to call your compare function.  It also
    makes a good boiler plate for similar uses of calling a function by
    reference.  The call passes the offset or address of the function to be
    called via the integer parameter the_call.  }

  begin
    inline
     (
    { Return Turbo to state right after call }
      $8B/$E5/               { mov SP,BP }
      $5D/                   { pop BP }

    { Now pop off the return address, pop of the function reference,
      and reverse their order on the stack, then do a far ret, which
      will return to the function reference, leaving the stack as if
      it went there in the first place.  Was that clear ?}
      $58/                   { pop  AX   ; return address }
      $5B/                   { pop  BX                    }
      $59/                   { pop  CX   ; Function       }
      $5A/                   { pop  DX   ; reference      }
      $53/                   { push BX   ; push back      }
      $50/                   { push AX   ; return Address }
      $52/                   { push DX   ; push back      }
      $51/                   { push CX   ; function ref.  }
      $CB);                  { retf      ; do a far return}
   end;                      {             to function ref}
  *)
  {$F-}
  procedure swapdata (v1seg,v1ofs:word; v2seg,v2ofs:word; var temp; size : integer); external;

  { This is an assembly routine that swaps records of any length up to 64K.
    See SWAPDATA.ASM for source code.
    v1, v2, and temp are any variables of equal size, size is a value for the
    size of these variables.  This is faster than using move()}

  {----------------------------------------------------------------------------}
{$IFDEF DEBUGCODE}
  const
    TheResult : word = 0;
  function QSortResult:word;
   begin
     QSortResult := TheResult; TheResult := 0;
   end;

  {$F+}
  procedure QsortError(ErrorCode:word);
  begin
    if QSortDebug then
      Frterror(Find_Far_Caller(1),ErrorCode)
    else
      TheResult := ErrorCode;
  end;
  {$F-}
{$ENDIF}
  {----------------------------------------------------------------------------}
  procedure quick_sort;
  {
  (var sort_array ; rec_size, n_recs: word; compare_address : pointer);
  }

  var
   aseg : integer;
   temp2 : ^integer;
   temp1 : ^integer;
   temp3 : ^integer;
   temp4 : ^integer;


  {----------------------------------------------------------------------------}
  procedure sort_1 (left,right: word);

  { This is the recursive part }
  var
   i, j : integer;

  begin
    { temp1 is the mid point in the block passed to sort_1 }
    i:=(right - left) shr 1;
    move(mem[aseg:( i +(left - (i mod rec_size)))],temp1^,rec_size);

    i:=left;
    j:=right;

    while i < j do
      begin
      { move i up to a value near the mid point value
        and j down to a value near the mid point value }
      temp3 := ptr(aseg,i);
      while compare_function (temp3^,temp1^) < 0 do
        begin
        inc(i,rec_size);
        temp3 := ptr(aseg,i);
        end;
      temp4 := ptr(aseg,j);
      while compare_function (temp4^,temp1^) > 0 do
        begin
        dec(j,rec_size);
        temp4 := ptr(aseg,j);
        end;
      { now swap em if i is still below j }
      if i <= j then
        begin
        swapdata(aseg,i,aseg,j,temp2^,rec_size);
        inc(i,rec_size);
        dec(j,rec_size);
        end
      end;
    {Ok now sort the outside blocks }
    {$S+}
    if left < j then sort_1(left,j);
    if i < right then sort_1(i,right)
    {$S-}
    end;

  {********** MAIN CODE ***********}
  begin
    aseg := seg(sort_array);

    {$IFDEF DEBUGCODE }
    { check to see if valid function pointer }
    if @compare_function = nil then
      begin
      QsortError(BadFunctionPointer);
      exit;
      end;

    { Check to see if valid array pointer }
    if aseg = 0 then
      begin
      QSorterror(BadArrayVarPointer);
      exit;
      end;

    { check to see if there is enough memory }
    if memavail < (rec_size*2) + $40  then
      begin
      QSorterror(MemoryOverflowError);
      exit;
      end;
    {$ENDIF}

    { Allocate Sapce on heap for Temp records }
    getmem(temp1,rec_size);
    getmem(temp2,rec_size);

    { OK if more than one record, Sort it }
    if n_recs > 1 then
      begin
      sort_1(ofs(sort_array),(ofs(sort_array))+(n_recs-1)*rec_size);
      end;

    { Unallocate heap space used }
    freemem(temp1,rec_size);
    freemem(temp2,rec_size);
  end;


  { --- INITIALIZATION ROUTINE ---- }
  begin
  end.